home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
HPAVC
/
HPAVC CD-ROM.iso
/
UNHQX.ZIP
/
unhqx.pas
< prev
next >
Wrap
Pascal/Delphi Source File
|
1995-03-07
|
10KB
|
392 lines
(* UNHQX.PAS, Turbo Pascal 7.0 object-unit to decode Mac BinHex files *)
(* ---------------------------------------------------------------------- *)
(* by Robert Rothenburg Walking-Owl, <robert.rothenburg@asb.com> *)
(* -- CopyLeft 1994 - Feel free to use and modify as needed, but please *)
(* only distribute unmodified source code. If you make *)
(* any improvements, please let me know. *)
unit UnHQX;
(* Inline code has been used for improved speed and smaller size, though *)
(* the 'original' Pascal code is included in comments to facilitate port- *)
(* ing to other systems or flavors of Pascal. *)
interface
(* Buffer size is somewhat arbitrary. Larger buffer sizes should *)
(* decode faster. A better method would be to check available mem- *)
(* ory and allocate an appropriate sized-buffer... *)
type
TBuff = array [1..4096] of byte;
pBuff = ^TBuff;
HQX = object
private
fif: ^file;
LastChar: Char;
RLE: Byte;
DBuffSz,
DBuffPtr: Word;
DiskBuffer,
Bit_Buffer: pBuff;
procedure UpDateCRC(c: Word); virtual;
procedure PutBits(b: Word); virtual;
function ReadChar: Char; virtual;
procedure Fetch; virtual;
function Retrieve: Char; virtual;
function Decode(C: Char): Byte; virtual;
public
CRC,
Origin,
FilePtr: LongInt;
Cur,
Ptr: Word;
Loc: Byte;
Header: record
FName: string[63];
Version: Byte;
FType,
Author: array[1..4] of char;
FileCRC,
CRC,
Flags: Word;
DataLen,
RsrcLen: LongInt;
end;
constructor Init(var f: file; Orig: LongInt);
function fCRC: Word;
function fGetC: Char; virtual;
procedure fGetBlock(var Block; Size: word); virtual;
function fGetW: Word; virtual;
function fGetL: LongInt; virtual;
procedure fSeek(Position: LongInt); virtual;
procedure fSkip(Position: LongInt); virtual;
{ procedure fRewind(Position: LongInt); virtual; }
destructor Done;
end;
implementation
const
(* Bit_Sizes[x] = 1 ShL (x-1) *)
{ Bit_Sizes: array [1..8] of byte = ( 1, 2, 4, 8, 16, 32, 64, 128); }
NUL = #00;
TAB = #09;
LF = #10;
FF = #12;
CR = #13;
SP = #32;
RLEMARKER = #144; (* 0x90 = RLE marker *)
cTBuffSz = SizeOf(TBuff);
function SwapLong(x: LongInt): LongInt; assembler;
asm
MOV AX, [BP+6]
MOV DX, [BP+8]
XCHG AX, DX
XCHG AL, AH
XCHG DL, DH
end;
procedure HQX.UpDateCRC(c: Word);
var
i: Byte;
Temp: word;
begin
Temp := CRC;
asm
MOV CX, $0808
@BitLoop: SHL c, 1
TEST Temp, $8000
JZ @SkipConst
SHL Temp, 1
AND Temp, $FFFF
XOR Temp, $1021
JMP @SkipShift
@SkipConst: SHL Temp, 1
@SkipShift: MOV AX, c
SHR AX, CL
XOR Temp, AX
AND c, $00FF
DEC CH
OR CH, CH
JNZ @BitLoop
end;
(* --- Pascal code to do the same as the above inline code --- *)
{ for i:= 0 to 7 do begin
c := c ShL 1;
if (Temp and $8000)<>0
then Temp := ((Temp ShL 1) and $FFFF) xor $1021
else Temp := Temp ShL 1;
Temp := Temp xor (c ShR 8);
c := c and $FF;
end; }
CRC := Temp;
end;
function HQX.fCRC: Word;
begin
UpDateCRC(0);
UpDateCRC(0);
fCRC := CRC;
end;
procedure HQX.PutBits (b: Word);
var
Num: Byte;
PPtr: Word;
Hold: pointer;
begin
Hold := Bit_Buffer;
Num := Loc;
PPtr := Ptr;
asm
PUSH DS
LDS SI, Hold
MOV BX, PPtr
MOV AL, Num
MOV CX, $20 { num := 6 (Bit_Sizes[6] = 32;) }
@BitCycle: CMP AL, 0 { is Loc=0? }
JNE @NormLoc
MOV AL, $80 { Loc := $80 }
INC BX { inc (Ptr); }
CMP BX, cTBuffSz { is Ptr > SizeOf(TBuff)? }
JNA @PtrOk
MOV BX, 1
@PtrOk: MOV Byte Ptr DS:[SI+BX-1], 0
@NormLoc: TEST CX, b
JZ @Continue
OR Byte Ptr DS:[SI+BX-1], AL
@Continue: SHR AL, 1
SHR CL, 1
CMP CL, 0
JA @BitCycle
MOV PPtr, BX
MOV Num, AL
POP DS
end;
Ptr := PPtr;
Loc := Num;
(* --- Pascal code to do the same as the above inline code --- *)
{
num := 6;
repeat
if Loc = 0
then begin
Loc := $80;
inc (Ptr);
if Ptr>SizeOf(TBuff) then Ptr := 1;
Bit_Buffer^[Ptr] := 0;
end;
if ( (b and Bit_Sizes [num] ) <> 0)
then Bit_Buffer^ [Ptr] := Bit_Buffer^ [Ptr] or Loc;
Loc := Loc ShR 1;
dec (num)
until num = 0;
}
end;
function HQX.Decode(C: char): Byte;
const
Table: string[64] =
'!"#$%&''()*+,-012345689@ABCDEFGHIJKLMNPQRSTUVXYZ[`abcdefhijklmpqr';
var d: Byte;
begin
(* --- Pascal code to do the same as the above inline code --- *)
{ d := Pos(C,Table);
if d=0
then Decode := $FF
else Decode := Pred(d); }
asm
MOV SI, Offset Table+1
XOR BX, BX
MOV AL, C
@LookUpLoop: CMP AL, [SI+BX]
JE @FoundMatch
INC BX
CMP BL, 64
JL @LookUpLoop
MOV BL, $FF
@FoundMatch: MOV @Result, BL
end;
end;
function HQX.ReadChar: Char;
begin
if DBuffPtr > DBuffSz
then begin
BlockRead(fif^,DiskBuffer^,SizeOf(TBuff),DBuffSz);
DBuffPtr := 1
end;
ReadChar := Chr(DiskBuffer^[DBuffPtr]);
inc(DBuffPtr);
end;
procedure HQX.Fetch;
var C: char;
i: Word;
j: Byte;
begin
i := 4; (* 4 encoded chars <-> 3 raw chars *)
(* No. chars fethced related to buffer size... *)
repeat
C := ReadChar;
if (C<>CR) and (C<>LF) and (C<>TAB) and (C<>FF) and (C<>SP)
then if C = ':'
then begin
PutBits(0);
i := 1 (* Set an EoF flag needed! *)
end
else begin
j := Decode(C);
PutBits(j)
end;
dec(i);
until (i=0) or (DBuffSz=0);
end;
function HQX.Retrieve: Char;
begin
Retrieve := Chr(Bit_Buffer^[Cur]);
inc(Cur);
if Cur>SizeOf(TBuff)
then Cur := 1;
end;
function HQX.fGetC: Char;
var C,R: Char;
begin
if RLE<>0
then begin
R := LastChar;
dec(RLE);
end
else begin
if (Cur+1)>=Ptr { Cur+3 }
then Fetch;
C := Retrieve;
if C<>RLEMARKER
then begin
R := C;
LastChar := C
end
else begin
C := Retrieve;
if C=NUL
then begin
R := RLEMARKER;
LastChar := RLEMARKER;
end
else begin
R := LastChar;
RLE := ord(C)-2
end
end;
end;
UpdateCRC(Ord(R));
fGetC := R;
inc(FilePtr);
end;
procedure HQX.fGetBlock(var Block; Size: word);
var Buffer: TBuff absolute Block;
i: word;
begin
if Size<>0 (* Size cannot be more than SizeOf(TBuff) ! *)
then for i := 1 to Size do Buffer[i] := ord(fGetC);
end;
function HQX.fGetW: Word;
var i: word;
begin
fGetBlock(i,2);
fGetW := Swap(i); (* Automatically convert endianess *)
end;
function HQX.fGetL: LongInt;
var i: LongInt;
begin
fGetBlock(i,4);
fGetL := SwapLong(i)
end;
procedure HQX.fSeek(Position: LongInt);
var C: char;
begin
if FilePtr<Position (* Otherwise error?! *)
then repeat
C := fGetC;
until FilePtr=Position;
end;
procedure HQX.fSkip(Position: LongInt);
begin
if Position>0
then fSeek(FilePtr+Position)
end;
(* Bug: Routine seems to get caught in an infinite loop ... *)
{
procedure HQX.fRewind(Position: LongInt);
begin
if (RLE=0) and (Position<(SizeOf(TBuff)-8)) (* arbitrary *)
then repeat
dec(Cur);
if Cur=0
then Cur := SizeOf(TBuff);
dec(Position);
until Position=0;
end;
}
constructor HQX.Init(var f: file; Orig: LongInt);
var Temp : Word;
begin
RLE := 0;
LastChar := NUL;
Loc := $80;
Ptr := 1;
Cur := 1;
GetMem(Bit_Buffer,SizeOf(TBuff)); { Doesn't check MemAvail! }
GetMem(DiskBuffer,SizeOf(TBuff));
DBuffSz := 0;
DBuffPtr := 1;
FillChar(Bit_Buffer^,SizeOf(TBuff),NUL);
FilePtr := 0;
CRC := $0000;
fif := @f;
Seek(fif^,Orig);
(* Assumes Orig points to position in file relative to the *)
(* "(This file ..." header in most BinHex files *)
repeat until (ReadChar=':');
(* Read header information ... *)
FillChar(Header,SizeOf(Header),NUL);
Header.FName[0] := fGetC;
fGetBlock(Header.FName[1],Length(Header.FName));
Header.Version := Ord(fGetC);
fGetBlock(Header.FType,4);
fGetBlock(Header.Author,4);
Header.Flags := fGetW;
Header.DataLen := fGetL;
Header.RsrcLen := fGetL;
Header.FileCRC := fCRC;
Header.CRC := fGetW; (* What is the CRC algorithm? ... *)
end;
destructor HQX.Done;
begin
FreeMem(Bit_Buffer,SizeOf(TBuff));
FreeMem(DiskBuffer,SizeOf(TBuff));
end;
end.